home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / lib / xt / widget.c < prev    next >
C/C++ Source or Header  |  1992-10-23  |  10KB  |  320 lines
  1. #include "xt.h"
  2.  
  3. extern void XtManageChildren(), XtUnmanageChildren();
  4.  
  5. static Object P_Destroy_Widget();
  6.  
  7. Generic_Predicate (Widget)
  8.  
  9. Generic_Equal (Widget, WIDGET, widget)
  10.  
  11. Generic_Print (Widget, "#[widget %u]", POINTER(x))
  12.  
  13. static Object Internal_Make_Widget (finalize, widget) Widget widget; {
  14.     Object w;
  15.  
  16.     if (widget == 0)
  17.     return Sym_None;
  18.     w = Find_Object (T_Widget, (GENERIC)0, Match_Xt_Obj, widget);
  19.     if (Nullp (w)) {
  20.     w = Alloc_Object (sizeof (struct S_Widget), T_Widget, 0);
  21.     WIDGET(w)->tag = Null;
  22.     WIDGET(w)->widget = widget;
  23.     WIDGET(w)->free = 0;
  24.     XtAddCallback (widget, XtNdestroyCallback, Destroy_Callback_Proc,
  25.         (XtPointer)0);
  26.     Register_Object (w, (GENERIC)0,
  27.         finalize ? P_Destroy_Widget : (PFO)0, 0);
  28.     }
  29.     return w;
  30. }
  31.  
  32. /* Backwards compatibility: */
  33. Object Make_Widget (widget) Widget widget; {
  34.     return Internal_Make_Widget (1, widget);
  35. }
  36.  
  37. Object Make_Widget_Foreign (widget) Widget widget; {
  38.     return Internal_Make_Widget (0, widget);
  39. }
  40.  
  41. void Check_Widget (w) Object w; {
  42.     Check_Type (w, T_Widget);
  43.     if (WIDGET(w)->free)
  44.     Primitive_Error ("invalid widget: ~s", w);
  45. }
  46.  
  47. void Check_Widget_Class (w, class) Object w; WidgetClass class; {
  48.     Check_Widget (w);
  49.     if (XtClass (WIDGET(w)->widget) != class)
  50.     Primitive_Error ("widget not of expected class: ~s", w);
  51. }
  52.  
  53. static Object P_Destroy_Widget (w) Object w; {
  54.     Check_Widget (w);
  55.     XtDestroyWidget (WIDGET(w)->widget);
  56.     return Void;
  57. }
  58.  
  59. static Object P_Create_Shell (argc, argv) Object *argv; {
  60.     register char *sn = 0, *sc = 0;
  61.     ArgList a;
  62.     Object name = argv[0], class = argv[1], w = argv[2], d = argv[3], ret;
  63.     Declare_C_Strings;
  64.  
  65.     if (!EQ(name, False))
  66.     Make_C_String (name, sn);
  67.     if (!EQ(class, False))
  68.     Make_C_String (class, sc);
  69.     Check_Type (w, T_Class);
  70.     Check_Type (d, T_Display);
  71.     Encode_Arglist (argc-4, argv+4, a, (Widget)0, CLASS(w)->class);
  72.     ret =  Make_Widget (XtAppCreateShell (sn, sc, CLASS(w)->class,
  73.     DISPLAY(d)->dpy, a, (Cardinal)(argc-4)/2));
  74.     Dispose_C_Strings;
  75.     return ret;
  76. }
  77.  
  78. static Object P_Create_Widget (argc, argv) Object *argv; {
  79.     ArgList a;
  80.     char *name = 0;
  81.     Object x = argv[0], class, parent, ret;
  82.     Declare_C_Strings;
  83.  
  84.     if (TYPE(x) != T_Class) {
  85.     Make_C_String (x, name);
  86.     argv++; argc--;
  87.     }
  88.     class = argv[0];
  89.     parent = argv[1];
  90.     Check_Type (class, T_Class);
  91.     Check_Widget (parent);
  92.     if (name == 0)
  93.     name = CLASS(class)->name;
  94.     Encode_Arglist (argc-2, argv+2, a, WIDGET(parent)->widget,
  95.     CLASS(class)->class);
  96.     ret =  Make_Widget (XtCreateWidget ((String)name, CLASS(class)->class,
  97.     WIDGET(parent)->widget, a, (Cardinal)(argc-2)/2));
  98.     Dispose_C_Strings;
  99.     return ret;
  100. }
  101.  
  102. static Object P_Realize_Widget (w) Object w; {
  103.     Check_Widget (w);
  104.     XtRealizeWidget (WIDGET(w)->widget);
  105.     return Void;
  106. }
  107.  
  108. static Object P_Unrealize_Widget (w) Object w; {
  109.     Check_Widget (w);
  110.     XtUnrealizeWidget (WIDGET(w)->widget);
  111.     return Void;
  112. }
  113.  
  114. static Object P_Widget_Realizedp (w) Object w; {
  115.     Check_Widget (w);
  116.     return XtIsRealized (WIDGET(w)->widget) ? True : False;
  117. }
  118.  
  119. static Object P_Widget_Display (w) Object w; {
  120.     Check_Widget (w);
  121.     return Make_Display (0, XtDisplay (WIDGET(w)->widget));
  122. }
  123.  
  124. static Object P_Widget_Parent (w) Object w; {
  125.     Check_Widget (w);
  126.     return Make_Widget_Foreign (XtParent (WIDGET(w)->widget));
  127. }
  128.  
  129. static Object P_Widget_Name (w) Object w; {
  130.     char *s;
  131.  
  132.     Check_Widget (w);
  133.     s = XtName (WIDGET(w)->widget);
  134.     return Make_String (s, strlen (s));
  135. }
  136.  
  137. static Object P_Widget_To_Window (w) Object w; {
  138.     Check_Widget (w);
  139.     return Make_Window (0, XtDisplay (WIDGET(w)->widget),
  140.     XtWindow (WIDGET(w)->widget));
  141. }
  142.  
  143. static Object P_Widget_Compositep (w) Object w; {
  144.     Check_Widget (w);
  145.     return XtIsComposite (WIDGET(w)->widget) ? True : False;
  146. }
  147.  
  148. static Object Manage_Unmanage (children, f) Object children; void (*f)(); {
  149.     register i, n;
  150.     Widget *buf;
  151.     Object tail;
  152.     Alloca_Begin;
  153.  
  154.     Check_List (children);
  155.     n = Fast_Length (children);
  156.     Alloca (buf, Widget*, n * sizeof (Widget));
  157.     for (i = 0, tail = children; i < n; i++, tail = Cdr (tail)) {
  158.     Object w = Car (tail);
  159.     Check_Widget (w);
  160.     buf[i] = WIDGET(w)->widget;
  161.     }
  162.     f (buf, n);
  163.     Alloca_End;
  164.     return Void;
  165. }
  166.  
  167. static Object P_Manage_Children (children) Object children; {
  168.     return Manage_Unmanage (children, XtManageChildren);
  169. }
  170.  
  171. static Object P_Unmanage_Children (children) Object children; {
  172.     return Manage_Unmanage (children, XtUnmanageChildren);
  173. }
  174.  
  175. static Object P_Widget_Managedp (w) Object w; {
  176.     Check_Widget (w);
  177.     return XtIsManaged (WIDGET(w)->widget) ? True : False;
  178. }
  179.  
  180. static Object P_Widget_Class (w) Object w; {
  181.     Check_Widget (w);
  182.     return Make_Widget_Class (XtClass (WIDGET(w)->widget));
  183. }
  184.  
  185. static Object P_Widget_Superclass (w) Object w; {
  186.     Check_Widget (w);
  187.     if (XtClass (WIDGET(w)->widget) == widgetClass)
  188.     return Sym_None;
  189.     return Make_Widget_Class (XtSuperclass (WIDGET(w)->widget));
  190. }
  191.  
  192. static Object P_Widget_Subclassp (w, c) Object w, c; {
  193.     Check_Widget (w);
  194.     Check_Type (c, T_Class);
  195.     return XtIsSubclass (WIDGET(w)->widget, CLASS(c)->class) ? True : False;
  196. }
  197.  
  198. static Object P_Set_Mapped_When_Managed (w, m) Object w, m; {
  199.     Check_Widget (w);
  200.     Check_Type (m, T_Boolean);
  201.     XtSetMappedWhenManaged (WIDGET(w)->widget, EQ(m, True));
  202.     return Void;
  203. }
  204.  
  205. static Object P_Map_Widget (w) Object w; {
  206.     Check_Widget (w);
  207.     XtMapWidget (WIDGET(w)->widget);
  208.     return Void;
  209. }
  210.  
  211. static Object P_Unmap_Widget (w) Object w; {
  212.     Check_Widget (w);
  213.     XtUnmapWidget (WIDGET(w)->widget);
  214.     return Void;
  215. }
  216.  
  217. static Object P_Set_Values (argc, argv) Object *argv; {
  218.     ArgList a;
  219.     Widget w;
  220.     register i, n = (argc-1)/2;
  221.     Alloca_Begin;
  222.  
  223.     Check_Widget (argv[0]);
  224.     w = WIDGET(argv[0])->widget;
  225.     Encode_Arglist (argc-1, argv+1, a, w, XtClass (w));
  226.     XtSetValues (w, a, (Cardinal)n);
  227.     for (i = 0; i < n; i++)
  228.     if (streq (a[i].name, XtNdestroyCallback))
  229.         Fiddle_Destroy_Callback (w);
  230.     Alloca_End;
  231.     return Void;
  232. }
  233.  
  234. static Object P_Get_Values (argc, argv) Object *argv; {
  235.     Widget w;
  236.  
  237.     Check_Widget (argv[0]);
  238.     w = WIDGET(argv[0])->widget;
  239.     return Get_Values (w, argc-1, argv+1);
  240. }
  241.  
  242. static Object P_Widget_Context (w) Object w; {
  243.     Check_Widget (w);
  244.     return
  245.     Make_Context_Foreign (XtWidgetToApplicationContext (WIDGET(w)->widget));
  246. }
  247.  
  248. static Object P_Set_Sensitive (w, s) Object w, s; {
  249.     Check_Widget (w);
  250.     Check_Type (s, T_Boolean);
  251.     XtSetSensitive (WIDGET(w)->widget, EQ(s, True));
  252.     return Void;
  253. }
  254.  
  255. static Object P_Sensitivep (w) Object w; {
  256.     Check_Widget (w);
  257.     return XtIsSensitive (WIDGET(w)->widget) ? True : False;
  258. }
  259.  
  260. static Object P_Window_To_Widget (w) Object w; {
  261.     Check_Type (w, T_Window);
  262.     return Make_Widget_Foreign (XtWindowToWidget (WINDOW(w)->dpy,
  263.     WINDOW(w)->win));
  264. }
  265.  
  266. static Object P_Name_To_Widget (root, name) Object root, name; {
  267.     register char *s;
  268.     Object ret;
  269.     Declare_C_Strings;
  270.  
  271.     Check_Widget (root);
  272.     Make_C_String (name, s);
  273.     ret = Make_Widget_Foreign (XtNameToWidget (WIDGET(root)->widget, s));
  274.     Dispose_C_Strings;
  275.     return ret;
  276. }
  277.  
  278. static Object P_Widget_Translate_Coordinates (w, x, y) Object w, x, y; {
  279.     Position root_x, root_y;
  280.  
  281.     Check_Widget (w);
  282.     XtTranslateCoords (WIDGET(w)->widget, Get_Integer (x), Get_Integer (y),
  283.     &root_x, &root_y);
  284.     return Cons (Make_Fixnum (root_x), Make_Fixnum (root_y));
  285. }
  286.  
  287. init_xt_widget () {
  288.     Generic_Define (Widget, "widget", "widget?");
  289.     Define_Primitive (P_Destroy_Widget,    "destroy-widget",    1, 1, EVAL);
  290.     Define_Primitive (P_Create_Shell,      "create-shell",  4, MANY, VARARGS);
  291.     Define_Primitive (P_Create_Widget,     "create-widget", 2, MANY, VARARGS);
  292.     Define_Primitive (P_Realize_Widget,    "realize-widget",    1, 1, EVAL);
  293.     Define_Primitive (P_Unrealize_Widget,  "unrealize-widget",  1, 1, EVAL);
  294.     Define_Primitive (P_Widget_Realizedp,  "widget-realized?",  1, 1, EVAL);
  295.     Define_Primitive (P_Widget_Display,    "widget-display",    1, 1, EVAL);
  296.     Define_Primitive (P_Widget_Parent,     "widget-parent",     1, 1, EVAL);
  297.     Define_Primitive (P_Widget_Name,       "widget-name",       1, 1, EVAL);
  298.     Define_Primitive (P_Widget_To_Window,  "widget->window",    1, 1, EVAL);
  299.     Define_Primitive (P_Widget_Compositep, "widget-composite?", 1, 1, EVAL);
  300.     Define_Primitive (P_Manage_Children,   "manage-children",   1, 1, EVAL);
  301.     Define_Primitive (P_Unmanage_Children, "unmanage-children", 1, 1, EVAL);
  302.     Define_Primitive (P_Widget_Managedp,   "widget-managed?",   1, 1, EVAL);
  303.     Define_Primitive (P_Widget_Class,      "widget-class",      1, 1, EVAL);
  304.     Define_Primitive (P_Widget_Superclass, "widget-superclass", 1, 1, EVAL);
  305.     Define_Primitive (P_Widget_Subclassp,  "widget-subclass?",  2, 2, EVAL);
  306.     Define_Primitive (P_Set_Mapped_When_Managed,
  307.                   "set-mapped-when-managed!",   2, 2, EVAL);
  308.     Define_Primitive (P_Map_Widget,        "map-widget",        1, 1, EVAL);
  309.     Define_Primitive (P_Unmap_Widget,      "unmap-widget",      1, 1, EVAL);
  310.     Define_Primitive (P_Set_Values,        "set-values!",   1, MANY, VARARGS);
  311.     Define_Primitive (P_Get_Values,        "get-values",    1, MANY, VARARGS);
  312.     Define_Primitive (P_Widget_Context,    "widget-context",    1, 1, EVAL);
  313.     Define_Primitive (P_Set_Sensitive,     "set-sensitive!",    2, 2, EVAL);
  314.     Define_Primitive (P_Sensitivep,        "widget-sensitive?", 1, 1, EVAL);
  315.     Define_Primitive (P_Window_To_Widget,  "window->widget",    1, 1, EVAL);
  316.     Define_Primitive (P_Name_To_Widget,    "name->widget",      2, 2, EVAL);
  317.     Define_Primitive (P_Widget_Translate_Coordinates,
  318.                 "widget-translate-coordinates", 3, 3, EVAL);
  319. }
  320.